home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / SIOD / Small-Siod.scm < prev    next >
Encoding:
Text File  |  1993-09-24  |  3.6 KB  |  135 lines
  1. ; Scheme In One Define.
  2. ; 
  3. ; The garbage collector, the name and other parts of this program are
  4. ;
  5. ; *                     COPYRIGHT (c) 1989 BY                              *
  6. ; *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7. ;
  8. ; Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. ; rational numbers, debug utils, and other major enhancments by
  10. ;
  11. ; *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12. ;
  13. ; Permission  to use, copy, modify, distribute and sell this software and its
  14. ; documentation  for  any purpose and without fee is hereby granted, provided
  15. ; that  the  above  copyright  notice appear in all copies and that both that
  16. ; copyright   notice   and   this  permission  notice  appear  in  supporting
  17. ; documentation,  and that the name of Paradigm Associates Inc not be used in
  18. ; advertising or publicity pertaining to distribution of the software without
  19. ; specific, written prior permission.
  20. ;
  21. ; Small runtime library for version 2.6
  22.  
  23.  
  24. (define (caar x) (cxr x "aa"))
  25. (define (cadr x) (cxr x "da"))
  26. (define (cdar x) (cxr x "ad"))
  27. (define (cddr x) (cxr x "dd"))
  28.  
  29. (define (caaar x) (cxr x "aaa"))
  30. (define (caadr x) (cxr x "daa"))
  31. (define (cadar x) (cxr x "ada"))
  32. (define (caddr x) (cxr x "dda"))
  33.  
  34. (define (cdaar x) (cxr x "aad"))
  35. (define (cdadr x) (cxr x "dad"))
  36. (define (cddar x) (cxr x "add"))
  37. (define (cdddr x) (cxr x "ddd"))
  38.  
  39. (macro delay (lambda (x)
  40.                  `(cons #f
  41.                        (lambda () ,(cadr x)))))
  42.  
  43. (define (force x) 
  44.         (if (car x)
  45.             (cdr x) 
  46.             (begin (set-cdr! x ((cdr x)))
  47.                    (set-car! x #t)
  48.                    (cdr x))))
  49. (macro cons-stream 
  50.        (lambda (x)
  51.                `(cons ,(cadr x)
  52.                       (delay ,(caddr x)))))
  53.  
  54. (define head car)
  55.  
  56. (define (tail x) (force (cdr x)))
  57.  
  58. (define the-empty-stream 'the-empty-stream)
  59.  
  60. (define (empty-stream? x) (eq? x 'the-empty-stream))
  61.  
  62. (define (stream->list z)
  63.         (if (empty-stream? z)
  64.             '()
  65.             (cons (head z) (stream->list (tail z)))))
  66.  
  67. (define (list->stream z)
  68.         (if (null? z)
  69.             the-empty-stream
  70.             (cons-stream (car z) (list->stream (cdr z)))))
  71.  
  72. (define (open-input-file x) (open-port x "r" 1))
  73.  
  74. (define (open-output-file x) (open-port x "w" 1))
  75.  
  76. (define (newline . x) (display #\newline (car x)))
  77.  
  78. (define (page . x) (display #\page (car x)))
  79.  
  80. (define (string<? x y)
  81.         (< (string-cmp x y) 0))        
  82.  
  83. (define (string>? x y)
  84.         (> (string-cmp x y) 0))
  85.  
  86. (define (string=? x y)
  87.         (= (string-cmp x y) 0))
  88.  
  89. (define (string<=? x y)
  90.         (<= (string-cmp x y) 0))
  91.  
  92. (define (string>=? x y)
  93.         (>= (string-cmp x y) 0))
  94.  
  95. (define (substring<? x y z a b c)
  96.         (string<? (substring x y z) (substring a b c)))
  97.  
  98. (define (substring=? x y z a b c)
  99.         (string=? (substring x y z) (substring a b c)))
  100.  
  101. (define (substring-fill! x y z a)
  102.         (while (< y z)
  103.                (string-set! x y a)
  104.                (set! y (1+ y)))
  105.         x)
  106.  
  107. (define (char<? x y)
  108.         (< (char-cmp x y) 0))   
  109.      
  110. (define (char>? x y)
  111.         (> (char-cmp x y) 0))
  112.                    
  113. (define (char=? x y)
  114.         (= (char-cmp x y) 0))
  115.  
  116. (define (char<=? x y)
  117.         (<= (char-cmp x y) 0))
  118.  
  119. (define (char>=? x y)
  120.         (>= (char-cmp x y) 0))
  121.  
  122. (define #\newline (integer->char 10))
  123.  
  124. (define #\page (integer->char 12))
  125.  
  126. (define #\space (integer->char 32))
  127.  
  128. (macro make-environment (lambda (x)
  129.                                 `(let () 
  130.                                       ,@(cdr x) 
  131.                                       (the-environment))))
  132.  
  133. (define (ced)
  134.         (dos-call "ced"))
  135.